home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / prolog / ai.prl / gulp.pl < prev    next >
Encoding:
Text File  |  1993-07-21  |  30.3 KB  |  1,189 lines
  1. %   GULP -- Graph Unification and Logic Programming
  2. %           Michael A. Covington
  3. %           Artificial Intelligence Programs
  4. %           University of Georgia
  5. %           Athens, Georgia 30602
  6.  
  7. %   For documentation see "GULP 2.0: An Extension of Prolog
  8. %   for Unification-Based Grammar," available as a research
  9. %   report from the above address.
  10.  
  11. %   DO NOT EDIT WITH AHED --
  12. %   EDIT ONLY WITH AN EDITOR THAT PRESERVES ASCII TAB CHARACTERS.
  13.  
  14. %   This is the Quintus Prolog version.
  15. %   To obtain the Arity Prolog version, perform the
  16. %   following editing changes:
  17. %
  18. %      change all  /*-A*/  to  %-A
  19. %      change all  %+A     to  /*+A*/
  20. %      change all  /*+Q*/  to  %+Q
  21. %      change all  %-Q     to  /*-Q*/
  22. %
  23.  
  24. %   The ALS Prolog version (which we are not sure is complete!)
  25. %   can be obtained analogously, reading A as L above.
  26. %   (At Georgia we use a program called GULPMAKE to make these changes.)
  27.  
  28. %   Notation:    %+X or /*+X*/ means 'add this line in version X'.
  29. %                %-X or /*-X*/ means 'remove this line in version X'.
  30. %                Here X is A for Arity, Q for Quintus, L for ALS,
  31. %                and/or T for a version that prints test messages.
  32.  
  33. % -----------------------------------------------------------------
  34.  
  35. %   GULP is a syntactic extension of Prolog for handling
  36. %   feature structures.
  37.  
  38. %   GULP accepts a Prolog program containing a special notation
  39. %   for feature structures, and translates it into a standard
  40. %   Prolog program which is placed into the knowledge base.
  41. %   Feature structures are converted into an internal data type
  42. %   known as value lists.
  43.  
  44. % New in version 1.2:
  45. %   Correction of a serious bug that prevented g_translate from
  46. %     translating internal to external representation in Quintus.
  47. %   Correction of a bug that prevented ed/1 from working in Quintus.
  48. %   Deletion of some rarely used predicates (g_ed, g_listing, etc.)
  49. %     which had more commonly used synonyms (ed, list, etc.).
  50. %   Modification of list/1 to translate feature structures back into GULP
  51. %     notation before displaying them.
  52. %   Introduction of new utilities: list/0, g_error/1, writeln/1.
  53.  
  54. % New in version 2.0:
  55. %   The separator for feature-value pairs is .. rather than ::. For
  56. %     compatibility, :: is still accepted.
  57. %   A completely different method of translation using stored schemas,
  58. %     resulting in much faster translation of GULP notation into
  59. %     the internal representation for feature structures and vice versa.
  60. %   The g_features clause is OPTIONAL.
  61. %   Many minor changes have been made to the utility predicates
  62. %     available to the user.
  63. %   Backtranslation of feature structures containing variables is
  64. %     now correct.
  65. %   Nested loads are now supported. That is, a file being loaded can
  66. %     contain a directive such as ':- load file2.' which will be
  67. %     executed correctly.
  68.  
  69. /*******************************
  70.  * Source file integrity check *
  71.  *******************************/
  72.  
  73. % If GULPMAKE is run correctly, the following
  74. % lines will be commented out in all versions.
  75.  
  76. /*-A*/ %-Q /*-L*/       :- write('NOT A CORRECTLY PREPARED SOURCE FILE!'),
  77. /*-A*/ %-Q /*-L*/          put(7), put(7).
  78.  
  79. /**********************
  80.  * Version identifier *
  81.  **********************/
  82.  
  83. %+A          g_version('> GULP 2.0d for Arity Prolog 4.0').
  84. /*+Q*/             g_version('> GULP 2.0d for Quintus Prolog 2.0').
  85. %+L             g_version('> GULP 2.0d for ALS Prolog 1.2').
  86.  
  87. /*+Q*/             :- g_version(X), version(X).
  88.  
  89.  
  90. /*************************
  91.  * Operator declarations *
  92.  *************************/
  93.  
  94. %+A          :- reset_op.
  95.  
  96.                 :- op(600,xfy,':').
  97.                 :- op(601,xfy,'..').
  98.                 :- op(601,xfy,'::').
  99.  
  100. /* Deprive 'case' of its operator status in Arity Prolog.
  101.    This makes the 'case' statement unusable but allows us
  102.    to use 'case' without quotes as a feature name. */
  103.  
  104. %+A          :- op(0,fx,'case').
  105.  
  106.  
  107. /******************************************************************
  108.  * Translation of feature structures to value lists or vice versa *
  109.  ******************************************************************/
  110.  
  111. /*-L*/          :- public g_translate/2.
  112. %+A          :- visible g_translate/2.
  113.  
  114. g_translate(X,X) :-
  115.         var(X),
  116.         !.       /* Rare case, but not covered by other clauses */
  117.  
  118. g_translate(Structure,List) :-
  119.         var(List),
  120.         !,
  121.         nonvar(Structure),
  122.         g_tf(Structure,List).
  123.  
  124. g_translate(Structure,List) :-
  125.         nonvar(List),
  126.         g_tb(Structure,List).
  127.  
  128.  
  129. /*************************************************************
  130.  * Translation backward -- value lists to feature structures *
  131.  *************************************************************/
  132.  
  133. /*
  134.  * g_tb(FeatureStructure,ValueList)     "Translate Backward"
  135.  *
  136.  *   Translates backward using g_backward_schema.
  137.  */
  138.  
  139.  
  140. g_tb(Value,Value) :-
  141.         (
  142.         var(Value)
  143.         ;
  144.         atom(Value)
  145.         ;
  146.         number(Value)
  147. %+A        ;
  148. %+A        string(Value)
  149.     ),
  150.         !.
  151.  
  152.         /* Variables and atomic terms do not need any conversion. */
  153.  
  154. g_tb(FS,Term) :-
  155. %-Q  Term \= g_(_,_),
  156. /*+Q*/     \+ (Term = g_(_,_)),
  157.         !,
  158.         Term =.. [Functor | Args],
  159.         g_tb_list(NewArgs,Args),
  160.         FS =.. [Functor | NewArgs].
  161.  
  162.         /* Term is a structure, but not a value list.
  163.            Recursively convert all its arguments, which
  164.            may be, or contain, value lists. */
  165.  
  166. g_tb(FS,Term) :-
  167.         call(g_backward_schema(RawFS,Term)),
  168.         g_tb_fixup(RawFS,FS).
  169.  
  170.         /* If we get here, we know Term is a value list. */
  171.  
  172.  
  173. /*
  174.  * g_tb_fixup(RawFeatureStructure,FeatureStructure)
  175.  *
  176.  *   Reverses the order of the feature:value pairs.
  177.  *   Recursively backtranslates the values.
  178.  *   Also discards pairs with uninstantiated value.
  179.  */
  180.  
  181.  
  182. g_tb_fixup(F:V,Result) :-                  /* Singleton case */
  183.         g_tb_fixup_rest(F:V,_,Result).
  184.  
  185. g_tb_fixup(F:V..Rest,Result) :-
  186.         g_tb(BTV,V),
  187.         g_tb_add(F:BTV,_,FV),
  188.         g_tb_fixup_rest(Rest,FV,Result).   /* Start the recursion */
  189.  
  190. g_tb_fixup_rest(F:V..Rest,ResultSoFar,Result) :-
  191.         g_tb(BTV,V),
  192.         g_tb_add(F:BTV,ResultSoFar,FVR),
  193.         g_tb_fixup_rest(Rest,FVR,Result).  /* Continue the recursion */
  194.  
  195. g_tb_fixup_rest(F:V,ResultSoFar,FVR) :-
  196.         g_tb(BTV,V),
  197.         g_tb_add(F:BTV,ResultSoFar,FVR).   /* End the recursion */
  198.  
  199.  
  200. g_tb_add(_:V,R,R)          :- var(V), !.   /* Unmentioned variable */
  201. g_tb_add(F:g_(V),R,F:V)    :- var(R).      /* First contribution
  202.                                                         to empty R */
  203. g_tb_add(F:g_(V),R,F:V..R) :- nonvar(R).   /* Ordinary case */
  204.  
  205.  
  206. /*
  207.  * g_tb_list(FeatureStructureList,ValueListList)
  208.  *
  209.  *   Applies g_tb to ValueListList giving FeatureStructureList.
  210.  */
  211.  
  212.  
  213. g_tb_list([],[]).
  214.  
  215. g_tb_list([FH|FT],[VH|VT]) :-
  216.         g_tb(FH,VH),
  217.         g_tb_list(FT,VT).
  218.  
  219.  
  220.  
  221. /************************************************************
  222.  * Translation forward -- feature structures to value lists *
  223.  ************************************************************/
  224.  
  225. /*
  226.  * This is more complicated than translation backward because any
  227.  * feature can occur anywhere in the feature structure. If several
  228.  * features are specified, separate value lists are constructed
  229.  * for them and then unified. Recursion is performed because the
  230.  * the value of a feature structure may itself be a feature structure.
  231.  */
  232.  
  233. /*
  234.  * g_tf(FeatureStructure,ValueList)     "Translate Forward"
  235.  *
  236.  *  Recursively examines FeatureStructure and replaces all
  237.  *  feature structures with equivalent value lists.
  238.  */
  239.  
  240.  
  241. g_tf(Term,Term) :-
  242.         (
  243.         var(Term)
  244.         ;
  245.         atom(Term)
  246.         ;
  247.         number(Term)
  248. %+A        ;
  249. %+A        string(Term)
  250.     ),
  251.         !.
  252.  
  253.         /* Simplest and most frequent case: Term is atomic. */
  254.  
  255. g_tf(Term,_) :-
  256.         g_not_fs(Term),
  257.         Term =.. [X|_],
  258.         (X = ':' ; X = '..' ; X = '::'),
  259.         !,
  260.         g_error(['Invalid GULP punctuation: ' ,Term]).
  261.  
  262.         /* If Term is a structure with a colon as its functor,
  263.            but is not a valid feature structure, then we have
  264.            a syntax error. */
  265.  
  266.         /* This clause is presently a time-waster.
  267.            It needs to be combined with the following clause. */
  268.  
  269. g_tf(Term,NewTerm) :-
  270.         g_not_fs(Term),
  271.         !,
  272.         Term =.. [Functor|Args],
  273.         g_tf_list(Args,NewArgs),
  274.         NewTerm =.. [Functor|NewArgs].
  275.  
  276.         /* Term is a structure, but not a feature structure.
  277.            Recurse on all its arguments, which may be, or
  278.            contain, feature structures. */
  279.  
  280. g_tf(Feature:Value,ValueList) :-
  281.         !,
  282.         g_tf(Value,NewValue),
  283.         g_tfsf(Feature,g_(NewValue),ValueList).
  284.  
  285.         /* We have a Feature:Value pair. Recursively
  286.            translate the value, which may itself be
  287.            or contain a feature structure, and then
  288.            convert Feature:NewValue into a value list
  289.            in which only one value is specified. */
  290.  
  291.         /* In Version 2, this adds g_/1 in front
  292.            of every value actually mentioned in
  293.            the program. */
  294.  
  295.  
  296. g_tf(FeatureStructure .. Rest,ValueList) :-
  297.         !,
  298.         g_tf(FeatureStructure,VL1),
  299.         g_tf(Rest,VL2),
  300.         g_unify(FeatureStructure..Rest,VL1,VL2,ValueList).
  301.  
  302.         /* A compound feature structure is handled by
  303.            translating all the feature structures
  304.            individually and then unifying the resulting
  305.            value lists. */
  306.  
  307.  
  308. g_tf(FeatureStructure :: Rest,ValueList) :-
  309.         g_tf(FeatureStructure .. Rest,ValueList).
  310.  
  311.         /* Older notation is still accepted for
  312.            compatibility. */
  313.  
  314.  
  315. /*
  316.  * g_tf_list(ListOfTerms,ListOfResults)  "Translate Forward List"
  317.  *
  318.  *       Applies g_tf to a list of arguments giving a list of results.
  319.  */
  320.  
  321.  
  322. g_tf_list([],[]).
  323.  
  324. g_tf_list([H|T],[NewH|NewT]) :-
  325.         g_tf(H,NewH),
  326.         g_tf_list(T,NewT).
  327.  
  328.  
  329. /*
  330.  * g_tfsf(Keyword,Value,ValueList)      "Translate Forward Single Feature"
  331.  *
  332.  *      Turns a keyword and a value into a value list in which
  333.  *      only one feature is specified.
  334.  */
  335.  
  336.  
  337. /*  Totally new in version 2.0  */
  338.  
  339. /*+Q*/             :- dynamic g_forward_schema/3.
  340.  
  341. g_tfsf(Keyword,Value,ValueList) :-
  342.         call_if_possible(g_forward_schema(Keyword,Value,ValueList)),
  343.         !.
  344.  
  345. g_tfsf(Keyword,Value,ValueList) :-
  346. %+T    nl,
  347. %+T    writeln(['Generating declaration for feature: ',Keyword]),
  348.         ( retract(g_features(List)) ; List = [] ),
  349.         !,   /* the above line should not generate alternatives */
  350.         append(List,[Keyword],NewList),
  351.         asserta(g_features(NewList)),
  352.         g_make_forward_schema(Keyword,NewList,X,Schema),
  353.         assertz(g_forward_schema(Keyword,X,Schema)),
  354.         g_make_backward_schema,
  355.         !,
  356.         g_tfsf(Keyword,Value,ValueList).
  357.              /* Try again, and this time succeed! */
  358.              /* Query: Will Quintus handle this right??? */
  359.  
  360.  
  361. /********************************
  362.  * Output of feature structures *
  363.  ********************************/
  364.  
  365. /*
  366.  * g_display(X)
  367.  *
  368.  *   Equivalent to display_feature_structure(X).
  369.  *   Retained for compatibility.
  370.  *
  371.  */
  372.  
  373. /*-L*/          :- public g_display/1.
  374. %+A          :- visible g_display/1.
  375.  
  376. g_display(X) :- display_feature_structure(X).
  377.  
  378.  
  379. /*
  380.  * display_feature_structure(X)
  381.  *
  382.  *   Writes out a feature structure in a neat indented format.
  383.  *   Feature structure can be in either Feature:Value notation
  384.  *   or internal representation.
  385.  */
  386.  
  387. /*-L*/          :- public display_feature_structure/1.
  388. %+A          :- visible display_feature_structure/1.
  389.  
  390. display_feature_structure(Term) :-
  391.         g_tb(FS,Term), /* Convert value lists into feature structures */
  392.         g_di(0,0,FS).  /* Display them */
  393.  
  394.  
  395. /*
  396.  * g_di(CurPos,Indent,FS)     "Display Indented"
  397.  *
  398.  *   CurPos is the current position on the line;
  399.  *   Indent is the indentation at which this item should be printed.
  400.  */
  401.  
  402. % This could be made more efficient by changing the order of
  403. % arguments so that indexing on the first argument would work.
  404.  
  405. g_di(CurPos,Indent,Variable) :-
  406.         var(Variable),
  407.         !,
  408.         g_di_tab(Indent,CurPos),
  409.         write(Variable),
  410.         nl.
  411.  
  412. g_di(CurPos,Indent,F:V..Rest) :-
  413.         !,
  414.         g_di(CurPos,Indent,F:V),
  415.         g_di(0,Indent,Rest).
  416.  
  417. g_di(CurPos,Indent,F:V::Rest) :-
  418.         !,
  419.         g_di(CurPos,Indent,F:V..Rest).  /* For compatibility */
  420.  
  421. g_di(CurPos,Indent,F:V) :-
  422.         !,
  423.         g_di_tab(Indent,CurPos),
  424.         write(F), write(': '),
  425.         g_printlength(F,PL),
  426.         NewIndent is Indent+PL+2,
  427.         g_di(NewIndent,NewIndent,V).
  428.  
  429. g_di(CurPos,Indent,OrdinaryTerm) :-
  430.         g_di_tab(Indent,CurPos),
  431.         write(OrdinaryTerm),
  432.         nl.
  433.  
  434.  
  435.  
  436. g_di_tab(Indent,CurPos) :-
  437.         Tabs is Indent-CurPos,
  438.         tab(Tabs).
  439.  
  440.  
  441. /************************************
  442.  * Management of the knowledge base *
  443.  ************************************/
  444.  
  445. /* Dynamic predicate declarations for Quintus */
  446.  
  447. /*+Q*/             :- dynamic g_loaded/1.
  448. /*+Q*/             :- dynamic g_preloaded/1.
  449. /*+Q*/             :- dynamic g_editing/1.
  450. /*+Q*/             :- dynamic g_ed_command/1.
  451.  
  452.  
  453. /*
  454.  * list
  455.  *
  456.  *   Displays all clauses that are known to have been
  457.  *   loaded from the user's file.
  458.  *
  459.  *   Note that DCG grammar rules will
  460.  *   be displayed as Prolog clauses.
  461.  */
  462.  
  463. /*-L*/          :- public list/0.
  464. %+A          :- visible list/0.
  465.  
  466. list :-
  467.         call_if_possible(g_loaded(P/A)),
  468.         list(P/A), nl,
  469.         fail.
  470.  
  471. list.
  472.  
  473.  
  474. /*-L*/          :- public list/1.
  475. %+A          :- visible list/1.
  476.  
  477. :- op(850,fx,list).
  478.  
  479.  
  480. /*
  481.  * list(Predicate/Arity)
  482.  *    like list/0 but lists only one predicate.
  483.  */
  484.  
  485. list(P/A) :-
  486.         functor(Struct,P,A),
  487.         clause(Struct,Body),
  488.         g_tb(FSStruct,Struct),
  489.         g_tb(FSBody,Body),
  490.         g_list_clause((FSStruct :- FSBody)),
  491.         fail.
  492.  
  493. /*
  494.  * list(Predicate)
  495.  *    lists all predicates with this name, regardless of arity.
  496.  */
  497.  
  498. list(P) :-
  499. /*+Q*/     \+ (P = _/_),
  500. %-Q  P \= _/_,
  501. /*+Q*/     current_predicate(P,Term), functor(Term,P,A),
  502. %-Q  current_predicate(P/A),
  503.         list(P/A),
  504.         fail.
  505.  
  506. list(_).   /* Catch-all for both list(P/A) and list(P). */
  507.  
  508.  
  509. g_list_clause((Head :- true)) :-
  510.         !,
  511.         write(Head), write('.'),
  512.         nl.
  513.  
  514. g_list_clause((Head :- Tail)) :-
  515.         write(Head), write(' :- '),
  516.         nl,
  517.         g_list_aux(Tail).
  518.  
  519.  
  520. g_list_aux((A,B)) :-
  521.         !,
  522.         write('    '),
  523.         write(A),
  524.         write(','),
  525.         nl,
  526.         g_list_aux(B).
  527.  
  528. g_list_aux(B) :-
  529.         write('    '),
  530.         write(B),
  531.         write('.'),
  532.         nl.
  533.  
  534.  
  535. /*
  536.  * ed(File)
  537.  *
  538.  *   Invokes the editor, which must be accessible by the
  539.  *   currently defined edit command (g_ed_command/1),
  540.  *   and then loads the file.
  541.  *
  542.  *   If the filename does not contain a period, '.GLP'
  543.  *   is appended.
  544.  *
  545.  *   File name can be given as either atom or string.
  546.  *   If omitted, the same file name is used as on the
  547.  *   previous call.
  548.  */
  549.  
  550. /*-L*/          :- public ed/0.
  551. %+A          :- visible ed/0.
  552.  
  553. ed :- call_if_possible(g_editing(File)), !, ed(File).
  554. ed :- writeln('No file specified'), !, fail.
  555.  
  556. /*-L*/          :- public ed/1.
  557. %+A          :- visible ed/1.
  558.  
  559. :- op(850,fy,ed).
  560.  
  561. ed(FN) :-
  562.         g_ed_fixup(FN,File),
  563.         (call(g_ed_command(Com)) ; g_ed_command(Com)),
  564.         append(Com,File,CommandString),
  565.         name(Command,CommandString),
  566.         write(Command),nl,
  567.         shell(Command),
  568.         write('[Finished editing]'),nl,
  569.         load(File).
  570.  
  571.  
  572. /*-L*/          :- public g_ed_command/1.
  573. %+A          :- visible g_ed_command/1.
  574.  
  575. %-Q  g_ed_command("edit ").
  576. /*+Q*/    % on VAX:    g_ed_command("$ fresh_emacs ").
  577. /*+Q*/                 g_ed_command("ue ").
  578.  
  579.   /* Assert your own command ahead of this one to change it. */
  580.  
  581.  
  582. /*
  583.  * g_ed_fixup(String1,String2)
  584.  *
  585.  *   takes filename String1 and adds suffix, if needed,
  586.  *   giving String2. (In GULP 1, String2 was an atom.)
  587.  */
  588.  
  589. g_ed_fixup(FN,FN) :-
  590.         FN = [_|_],
  591.         member(46,FN),   /* period */
  592.         !.
  593.  
  594. g_ed_fixup(FN,NewFN) :-
  595.         FN = [_|_],
  596.         !,
  597.         append(FN,".glp",NewFN).
  598.  
  599. g_ed_fixup(FN,File) :-
  600.         name(FN,FNList),
  601.         !,
  602.         g_ed_fixup(FNList,File).
  603.  
  604.  
  605.  
  606. /*
  607.  * new
  608.  *
  609.  *   Abolishes all user-loaded predicate definitions,
  610.  *   regardless of what file they were loaded from.
  611.  *   Also clears all feature definitions out of memory.
  612.  */
  613.  
  614. /*-L*/          :- public new/0.
  615. %+A          :- visible new/0.
  616.  
  617. new :-  call_if_possible(g_loaded(P/A)),
  618.         functor(Str,P,A),
  619.         retractall(Str),
  620. %+T     write('[Abolished '),write(P/A),write(']'),nl,
  621.         fail.
  622.  
  623. new :-  retractall(g_loaded(_)),
  624.         retractall(g_preloaded(_)),
  625.         retractall(g_forward_schema(_,_,_)),
  626.         retractall(g_backward_schema(_,_)),
  627.         retractall(g_features(_)),
  628. %+T     write('[Abolished g_loaded/1, g_preloaded/1, features, and schemas]'),
  629. %+T     nl,
  630.         fail.
  631.  
  632. new :-  /* g_clear_screen, */
  633.         g_herald.
  634.  
  635.  
  636. /*
  637.  * load(File)
  638.  *
  639.  *   Like reconsult, but clauses for a predicate need not be
  640.  *   contiguous. Embedded queries begin with ':-'.
  641.  */
  642.  
  643.  
  644. /*-L*/          :- public load/0.
  645. %+A          :- visible load/0.
  646.  
  647. load :- call_if_possible(g_editing(File)), !, load(File).
  648. load :- writeln('No file specified'), !, fail.
  649.  
  650.  
  651. /*-L*/          :- public load/1.
  652. %+A          :- visible load/1.
  653.  
  654. :- op(850,fx,load).
  655.  
  656. load(F) :-
  657.         g_ed_fixup(F,FN),
  658.         name(File,FN),
  659.         g_load_file(File),
  660.         (retract(g_editing(_)) ; true),
  661.         assert(g_editing(File)).
  662.  
  663.         /* g_editing is asserted AFTER load so that if there
  664.            are nested loads, the last file will win out. */
  665.  
  666.  
  667. /*
  668.  * g_load_file(File)
  669.  *
  670.  *   Given an atom as a filename, actually loads the file through
  671.  *   the GULP translator. Called by load/1.
  672.  */
  673.  
  674.  
  675. g_load_file(_) :-
  676.         nl,
  677.         retractall(g_preloaded(_)),
  678. %+T     writeln(['[Abolished g_preloaded/1]']),
  679.         fail.
  680.  
  681. g_load_file(_) :-
  682.         call_if_possible(g_loaded(PA)),
  683.         assertz(g_preloaded(PA)),
  684. %+T     writeln(['[Noted that ',PA,' was already there.]']),
  685.         fail.
  686.  
  687. g_load_file(File) :-
  688. %+A  open(Handle,File,r),            /* Arity */
  689. /*+Q*/     open(File,read,Handle),         /* Quintus */
  690.         write('> Reading '),write(File),
  691.         !,
  692.         repeat,
  693.                 read(Handle,Clause),
  694.                 g_assert(Clause),
  695.                 Clause == end_of_file,
  696.         !,
  697.         close(Handle),
  698.         nl,
  699.         write('> Features used: '),
  700.         ( setof(X,Y^Z^g_forward_schema(X,Y,Z),FL) ; FL='(None)' ),
  701.         write(FL),nl,
  702.         write('> Finished loading '),write(File).
  703.  
  704. g_load_file(File) :-
  705.         g_error(['Unable to complete loading file ',File]).
  706.                 /* Should the file be closed here? */
  707.  
  708.  
  709. /*
  710.  * g_assert(Clause)
  711.  *
  712.  *   Processes a newly read clause or embedded goal.
  713.  */
  714.  
  715. g_assert(end_of_file) :- !.
  716.  
  717. g_assert((:-X))     :-   !,    /* Do not use another clause */
  718.                          g_tf(X,NewX),
  719.                          expand_term(NewX,NewNewX),
  720.                          call(NewNewX),  /* not call_if_possible,
  721.                                             which would miss
  722.                                             system predicates */
  723.                          !.    /* Do not resatisfy NewNewX */
  724.  
  725. g_assert(g_features(List)) :-     /*
  726.                                * Combine new g_features
  727.                                    * with any pre-existing ones
  728.                                    */
  729.                                 (retract(g_features(Old)) ; Old = []),
  730.                 !,
  731.                 append(Old,List,New),
  732.                                 remove_duplicates(New,NewNew),
  733.                                   /*
  734.                                    * Discard pre-existing schemas
  735.                                    * and make a whole new set.
  736.                                    * (This wastes some time;
  737.                                    * later version should only
  738.                                    * generate the ones needed.)
  739.                                    */
  740.                                 abolish(g_forward_schema/3),
  741.                                 g_make_forward_schemas(NewNew),
  742.                                 abolish(g_backward_schema/2),
  743.                                 g_make_backward_schema,
  744.                                   /*
  745.                                    * Place the new g_features
  746.                                    * clause in the database.
  747.                                    */
  748.                                 g_note_loaded(g_features/1),
  749.                                 assertz(g_features(NewNew)).
  750.  
  751. g_assert(Clause) :- g_pred(Clause,PA),
  752.                     g_abolish_if_preloaded(PA),
  753.                     g_note_loaded(PA),
  754.                     g_tf(Clause,NewClause),
  755.                     expand_term(NewClause,NewNewClause),
  756.                     assertz(NewNewClause).
  757.  
  758. /*
  759.  * g_make_backward_schema
  760.  *
  761.  *   Makes a backtranslation schema containing all
  762.  *   possible features in both external and internal notation,
  763.  *   e.g., g_backward_schema(c:Z..b:Y..a:X,g_(X,g_(Y,g_(Z,_)))).
  764.  */
  765.  
  766. g_make_backward_schema :-
  767.         retractall(g_backward_schema(_,_)),
  768.         bagof((Feature:Value)/Schema,
  769.                 g_forward_schema(Feature,Value,Schema),
  770.                 [((F:V)/S)|Rest]),
  771.         g_make_whole_aux(Rest,F:V,S).
  772.  
  773.  
  774.  
  775. g_make_whole_aux([],FSSoFar,SchemaSoFar) :-
  776.         assert(g_backward_schema(FSSoFar,SchemaSoFar)).
  777.  
  778. g_make_whole_aux([((F:V)/S)|Rest],FSSoFar,SchemaSoFar) :-
  779.         NewFS = (F:V .. FSSoFar),
  780.         SchemaSoFar = S,  /* unify SchemaSoFar with S */
  781.         g_make_whole_aux(Rest,NewFS,SchemaSoFar).
  782.  
  783.  
  784. /*
  785.  * g_make_forward_schemas(List)
  786.  *
  787.  *   Given a list of feature names, makes and stores a
  788.  *   set of forward translation schemas for them.
  789.  */
  790.  
  791.  
  792. g_make_forward_schemas(List) :-
  793.         g_make_forward_schema(Feature,List,Variable,Schema),
  794.         assertz(g_forward_schema(Feature,Variable,Schema)),
  795.         fail.
  796.  
  797. g_make_forward_schemas(_).
  798.  
  799.  
  800. /*
  801.  * g_make_forward_schema(Feature,List,Variable,Schema)
  802.  *
  803.  *    Given List, returns as alternatives all the schemas
  804.  *    for the various features. Variable is a variable
  805.  *    occurring in Schema to contain the feature value.
  806.  */
  807.  
  808.  
  809. g_make_forward_schema(Feature,[Feature|_],X,g_(X,_)).
  810.  
  811. g_make_forward_schema(Feature,[_|Tail],X,g_(_,Schema)) :-
  812.         g_make_forward_schema(Feature,Tail,X,Schema).
  813.  
  814.         /* This is very much like using member/2 on
  815.            backtracking to find all members of a list. */
  816.  
  817.  
  818. /*
  819.  * g_pred(Clause,Pred/Arity)
  820.  *
  821.  *   Determines the predicate and arity of a clause.
  822.  */
  823.  
  824.  
  825. g_pred(Clause,Pred/Arity) :-  expand_term(Clause,(Head :- _)),
  826.                               !,
  827.                               functor(Head,Pred,Arity).
  828.  
  829. g_pred(Clause,Pred/Arity) :-  expand_term(Clause,NewClause),
  830.                               functor(NewClause,Pred,Arity).
  831.  
  832.  
  833. /*
  834.  * g_abolish_if_preloaded(Pred/Arity)
  835.  *
  836.  *   Abolishes a predicate if it is marked as "preloaded," i.e.,
  837.  *   was loaded from same file on a previous call to g_load.
  838.  */
  839.  
  840.  
  841. g_abolish_if_preloaded(P/A) :-
  842.                                 retract(g_preloaded(P/A)),
  843.                                 (retract(g_loaded(P/A)) ; true),
  844.                                 abolish(P/A),
  845. %+T                          nl,write('[Abolished '),write(P/A),write(']'),
  846.                                 !.
  847.  
  848. g_abolish_if_preloaded(_).
  849.  
  850.  
  851. /*
  852.  * g_note_loaded(PA)
  853.  *
  854.  */
  855.  
  856. g_note_loaded(PA) :-
  857.         call_if_possible(g_loaded(PA)),
  858.         !,
  859.         write('.'),
  860. /*+Q*/     ttyflush,
  861.         true.
  862.  
  863. g_note_loaded(PA) :-
  864.         assertz(g_loaded(PA)),
  865.         nl,
  866.         write(PA).
  867.  
  868.  
  869.  
  870. /****************************
  871.  * Miscellaneous predicates *
  872.  ****************************/
  873.  
  874. /*
  875.  * g_fs(X)       "Feature Structure"
  876.  *
  877.  *   Succeeds if X is a feature structure.
  878.  */
  879.  
  880. /*-L*/          :- public g_fs/1.
  881. %+A          :- visible g_fs/1.
  882.  
  883. g_fs(X:_) :- atom(X).
  884. g_fs(X..Y) :- g_fs(X), g_fs(Y).
  885. g_fs(X::Y) :- g_fs(X), g_fs(Y).  /* For compatibility */
  886.  
  887. /*
  888.  * g_not_fs(X)   "Not a Feature Structure"
  889.  *  (Avoids use of "not" in compiled Arity Prolog.)
  890.  */
  891.  
  892. /*-L*/          :- public g_not_fs/1.
  893. %+A          :- visible g_not_fs/1.
  894.  
  895. g_not_fs(X) :- g_fs(X), !, fail.
  896. g_not_fs(_).
  897.  
  898.  
  899. /*
  900.  * g_vl(X)          "Value List"
  901.  *
  902.  *   Succeeds if X is a value list.
  903.  */
  904.  
  905. /*-L*/          :- public g_vl/1.
  906. %+A          :- visible g_vl/1.
  907.  
  908. g_vl(g_(_,Y)) :- var(Y).
  909. g_vl(g_(_,Y)) :- g_vl(Y).
  910.  
  911.  
  912. /*
  913.  * g_unify(Text,X,Y,Z)
  914.  *      Unifies X and Y giving Z.
  915.  *      If this cannot be done, Text is used in an
  916.  *      error message.
  917.  */
  918.  
  919. g_unify(_,X,X,X) :- !.
  920.  
  921. g_unify(Text,X,Y,_) :-
  922. /*+Q*/     \+ (X = Y),
  923. %-Q  X \= Y,
  924.         g_error(['Inconsistency in ',Text]).
  925.  
  926.  
  927. /*
  928.  * g_printlength(Term,N)
  929.  *
  930.  *     N is the length of the printed representation of Term.
  931.  */
  932.  
  933. /*-L*/          :- public g_printlength/2.
  934. %+A          :- visible g_printlength/2.
  935.  
  936. g_printlength(Term,N) :-  name(Term,List),
  937.                           !,
  938.                           length(List,N).
  939.  
  940. g_printlength(_,0).  /* if not computable,
  941.                         we probably don't
  942.                         need an accurate value
  943.                         anyhow */
  944.  
  945. /*
  946.  * g_error(List)
  947.  *    Ensures that i/o is not redirected,
  948.  *    then displays a message and aborts program.
  949.  */
  950.  
  951.  
  952. g_error(List) :- repeat,
  953.                    seen,
  954.                    seeing(user),
  955.                  !,
  956.                  repeat,
  957.                    told,
  958.                    telling(user),
  959.                  !,
  960.                  writeln(['ERROR: '|List]),
  961.                  abort.
  962.  
  963.  
  964. /**************************************
  965.  *           I/O utilities            *
  966.  **************************************/
  967.  
  968. /*
  969.  *  g_clear_screen
  970.  */
  971.  
  972. g_clear_screen :-
  973. %+A          cls.
  974. /*-A*/             nl,nl,nl,nl,nl,nl,nl,nl.
  975.  
  976.  
  977. /*
  978.  * writeln(List)
  979.  *   writes the elements of List on a line, then
  980.  *   starts a new line. If the argument is not a list,
  981.  *   it is written on a line and then a new line is started.
  982.  *   Any feature structures found in List are converted
  983.  *   to Feature:Value notation.
  984.  */
  985.  
  986.  
  987. /*-L*/          :- public writeln/1.
  988. %+A          :- visible writeln/1.
  989.  
  990. writeln(X) :- g_tb(TranslatedX,X), writeln_aux(TranslatedX).
  991.  
  992. writeln_aux(X) :- var(X), !, write(X), nl.
  993. writeln_aux([]) :- !, nl.
  994. writeln_aux([H|T]) :- !, write(H), writeln(T).
  995. writeln_aux(X) :- write(X), nl.
  996.  
  997.  
  998.  
  999. /**************************************
  1000.  * Filling gaps in particular Prologs *
  1001.  **************************************/
  1002.  
  1003. /* These are built-in predicates from other Prologs that
  1004.    are defined here for implementations that lack them. */
  1005.  
  1006. /*
  1007.  * shell(Command)
  1008.  *   passes Command (an atom) to the operating system.
  1009.  */
  1010.  
  1011. /*+Q*/     :- public shell/1.
  1012. /*+Q*/
  1013. /*+Q*/     %VAX shell(Command) :- vms(dcl(Command)),nl.
  1014. /*+Q*/          shell(Command) :- unix(system(Command)),nl.
  1015.  
  1016.  
  1017. /*
  1018.  * append(X,Y,Z)
  1019.  *   concatenates lists X and Y giving Z.
  1020.  *   Has interchangeability of unknowns.
  1021.  */
  1022.  
  1023. /*-L*/          :- public append/3.
  1024. %+A          :- visible append/3.
  1025.  
  1026. append([],X,X).
  1027. append([H|T],X,[H|Y]) :- append(T,X,Y).
  1028.  
  1029.  
  1030. /*
  1031.  * member(Element,List)
  1032.  *   succeeds if Element is in List.
  1033.  *   Has interchangeability of unknowns.
  1034.  */
  1035.  
  1036. /*-L*/          :- public member/2.
  1037. %+A          :- visible member/2.
  1038.  
  1039. member(X,[X|_]).
  1040. member(X,[_|Y]) :- member(X,Y).
  1041.  
  1042. /*
  1043.  * remove_duplicates(List1,List2)
  1044.  *    makes a copy of List1 in which only the
  1045.  *    first occurrence of each element is present.
  1046.  *    List1 must be instantiated at time of call.
  1047.  */
  1048.  
  1049. /*-L*/          :- public remove_duplicates/2.
  1050. %+A          :- visible remove_duplicates/2.
  1051.  
  1052. remove_duplicates(X,Y) :-
  1053.         rem_dup_aux(X,Y,[]).
  1054.  
  1055. rem_dup_aux([],[],_).
  1056.  
  1057. rem_dup_aux([H|T],X,Seen) :-
  1058.         member(H,Seen),
  1059.         !,
  1060.         rem_dup_aux(T,X,Seen).
  1061.  
  1062. rem_dup_aux([H|T],[H|X],Seen) :-
  1063.         rem_dup_aux(T,X,[H|Seen]).
  1064.  
  1065.  
  1066. /*
  1067.  * retractall(Predicate)
  1068.  *    retracts all clauses of Predicate, if any.
  1069.  *    Always succeeds.
  1070.  */
  1071.  
  1072. %+A          :- public retractall/1.
  1073. %+A          :- visible retractall/1.
  1074.  
  1075. %-Q  retractall(Head) :- functor(Head,Functor,Arity),
  1076. %-Q                      abolish(Functor/Arity).
  1077.  
  1078.  
  1079. /*
  1080.  * phrase(PhraseType,InputString)
  1081.  *   Initiates DCG parsing.
  1082.  *   For example, ?- phrase(s,[the,dog,barks]) is
  1083.  *   equivalent to ?- s([the,dog,barks],[]).
  1084.  */
  1085.  
  1086. %+A          :- public phrase/2.
  1087. %+A          :- visible phrase/2.
  1088.  
  1089. %-Q phrase(X,Y) :- X =.. XL,
  1090. %-Q               append(XL,[Y,[]],GL),
  1091. %-Q               Goal =.. GL,
  1092. %-Q               call(Goal).
  1093.  
  1094.  
  1095. /*
  1096.  * copy(A,B)
  1097.  *   B is the same as A except that all the
  1098.  *   uninstantiated variables have been replaced
  1099.  *   by fresh variables, preserving the pattern
  1100.  *   of their occurrence.
  1101.  */
  1102.  
  1103. /*-L*/          :- public copy/2.
  1104. %+A          :- visible copy/2.
  1105.  
  1106.  
  1107. copy(X,Y) :- asserta(copy_aux(X)),
  1108.              retract(copy_aux(Y)).
  1109.  
  1110.  
  1111. /*
  1112.  * call_if_possible(Goal)
  1113.  *   Calls Goal.
  1114.  *   If there are no clauses for the predicate,
  1115.  *   the call fails but an error condition is not raised.
  1116.  */
  1117.  
  1118. /*-L*/          :- public call_if_possible/1.
  1119. %+A          :- visible call_if_possible/1.
  1120.  
  1121.  
  1122. call_if_possible(Goal) :-
  1123. %-Q          call(Goal).
  1124. /*+Q*/             current_predicate(_,Goal), call(Goal).
  1125.  
  1126.  
  1127. /**********
  1128.  * Herald *
  1129.  **********/
  1130.  
  1131. /*-L*/          :- public g_herald/0.
  1132. %+A          :- visible g_herald/0.
  1133.  
  1134. g_herald :- put(13),
  1135.             g_version(X), write(X), nl.
  1136.  
  1137. /*-A*/             :- g_herald.
  1138.  
  1139. /***************
  1140.  * End of GULP *
  1141.  ***************/
  1142.  
  1143. /*+Q*/     % * GULP COMPILATION UTILITY *
  1144. /*+Q*/
  1145. /*+Q*/   % Hastily hacked together (for Quintus Prolog only)
  1146. /*+Q*/   %  by Michael Covington, April 4, 1988.
  1147. /*+Q*/
  1148. /*+Q*/   %  By typing
  1149. /*+Q*/   %      ?- g_compile.
  1150. /*+Q*/   %  you can get GULP to write out the translated clauses
  1151. /*+Q*/   %  to a file named G_COMPILE.TMP, then compile them back
  1152. /*+Q*/   %  into memory. This is a good way to get a debugged
  1153. /*+Q*/   %  GULP program (or part of a program) to run much faster.
  1154. /*+Q*/
  1155. /*+Q*/   %  No guarantees -- this is a kludge! */
  1156. /*+Q*/
  1157. /*+Q*/
  1158. /*+Q*/   g_compile :-
  1159. /*+Q*/     write('Writing translated clauses. DO NOT INTERRUPT.'),nl,
  1160. /*+Q*/     (g_editing(F) ; F = 'unnamed file'),
  1161. /*+Q*/     tell('G_COMPILE.TMP'),
  1162. /*+Q*/     write(':- version(''Contains compiled code from '),
  1163. /*+Q*/     write(F),
  1164. /*+Q*/     write(' '').'),nl,
  1165. /*+Q*/     nl,
  1166. /*+Q*/     g_compile_aux,
  1167. /*+Q*/     told,
  1168. /*+Q*/     write('Invoking compiler...'),nl,
  1169. /*+Q*/     no_style_check(single_var),
  1170. /*+Q*/     compile('G_COMPILE.TMP'),
  1171. /*+Q*/     style_check(single_var),
  1172. /*+Q*/     write('Done.'),nl,
  1173. /*+Q*/     write('You may now save all the clauses in your workspace'),nl,
  1174. /*+Q*/     write('(both interpreted and compiled,'),nl,
  1175. /*+Q*/     write('including the entire GULP system)'),nl,
  1176. /*+Q*/     write('with the command'),nl,
  1177. /*+Q*/     write('   ?- save_program(yourfilename). '),nl,
  1178. /*+Q*/     write('The resulting file can be loaded with'),nl,
  1179. /*+Q*/     write('   ?- restore(yourfilename).'),nl,
  1180. /*+Q*/     write('or by entering Prolog with the command'),nl,
  1181. /*+Q*/     write('   $ prolog yourfilename'),nl,
  1182. /*+Q*/     nl.
  1183. /*+Q*/
  1184. /*+Q*/   g_compile_aux :- g_loaded(P/A,_),
  1185. /*+Q*/                    listing(P/A),
  1186. /*+Q*/                    fail.
  1187. /*+Q*/
  1188. /*+Q*/   g_compile_aux.  /* always succeeds */
  1189.